home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Diamond Collection / The Diamond Collection (Software Vault)(Digital Impact).ISO / cdr43 / xlibp202.zip / XBMP2.PAS < prev    next >
Pascal/Delphi Source File  |  1994-06-17  |  5KB  |  200 lines
  1. unit XBmp2;
  2. { ************************************************
  3.   **    BMP Decoding and Encoding procedures    **
  4.   **        for Borland/Turbo Pascal 7.0        **
  5.   **                                            **
  6.   **     Written by Tristan Tarrant, 1994       **
  7.   **                                            **
  8.     ************************************************ }
  9.  
  10. interface
  11.  
  12. uses
  13.     Dos, XMisc2;
  14.  
  15. type
  16.     BMPLineProcType = procedure( Var pixels; line, width : integer );
  17.     BMPPixelProcType = function( x, y : integer) : integer;
  18.  
  19. Var
  20.     { Pointers to custom procedures to deal with lines. BMPOutLineProc
  21.         is called with three parameters : an untyped var, containing
  22.         the uncompressed data, and two integer values, containing the
  23.         line number and the width of the line.
  24.         BMPInPixelProc should instead return a pixels value, -1 if at the
  25.         end of the data. }
  26.  
  27.     BMPOutLineProc : BMPLineProcType;
  28. { BMPOutLineProc is called with an untyped variable containing a row's
  29.     worth of pixels. The current line is given in line and the number of
  30.     pixels in a line is given in width}
  31.     BMPInPixelProc : BMPPixelProcType;
  32. { BMPInPixelProc should return a pixel value, -1 if at the end of the data.
  33.     Data should be returned width first (i.e. all pixels in row 0, then all
  34.     pixels in row 1, etc.}
  35.     BMPPalette : array[0..767] of byte;
  36. { BMPPalette is an array which contains the palette of the last loaded
  37.     BMP file}
  38.  
  39.  
  40. function SaveBMP( f : string; width, depth : integer; var palette ) : boolean;
  41. { This function saves a BMP file f with using screen size width*depth
  42.     and with a color resolution of 8 bits which translates to a 256 colour
  43.     image.
  44.     Palette contains the palette of the picture that is being saved.
  45.     SaveBMP uses #BMPInPixelProc# to get the picture data from the application.
  46.     It returns TRUE if successful, FALSE otherwise}
  47. function LoadBMP( f : string ) : boolean;
  48. { This function loads a BMP file f and returns TRUE if successful, FALSE
  49.     otherwise.
  50.     It uses the #BMPLineProc# procedure to send the decoded picture
  51.     to the application. The palette of the picture is stored in the
  52.     global variable #BMPPalette#}
  53.  
  54. implementation
  55.  
  56. type
  57.     BMPHeader = record
  58.         id : array[1..2] of char;
  59.         filesize,
  60.         reserved,
  61.         headersize,
  62.         infoSize,
  63.         wid,
  64.         hgt : longint;
  65.         biPlanes, bits : integer;
  66.         biCompression,
  67.         biSizeImage,
  68.         biXPelsPerMeter,
  69.         biYPelsPerMeter,
  70.         biClrUsed,
  71.         biClrImportant : longint;
  72.     end;
  73.  
  74.     BMPRGB = record
  75.         b, g, r, f : byte;
  76.     end;
  77.  
  78. function DecodeBMP( var f : file ) : boolean;
  79. var
  80.     BMPHead : BMPHeader;
  81.     hgt, wid, index : integer;
  82.     r, g, b : byte;
  83.     ScreenLine : pointer;
  84.     col : BMPRGB;
  85.  
  86. begin
  87.     blockread( f, BMPHead, SizeOf( BMPHead ) );
  88.     for index:=0 to 255 do
  89.     begin
  90.         blockread( f, col, SizeOf( BMPRGB ) );
  91.         BMPPalette[index*3] := col.r shr 2;
  92.         BMPPalette[index*3+1] := col.g shr 2;
  93.         BMPPalette[index*3+2] := col.b shr 2;
  94.     end;
  95.     wid := BMPHead.wid;
  96.     if wid mod 4<>0 then wid := wid + 4 - wid mod 4;
  97.     GetMem( ScreenLine, wid );
  98.     hgt := BMPHead.hgt-1;
  99.     for index:=hgt downto 0 do
  100.     begin
  101.         blockread( f, ScreenLine^, wid );
  102.         BMPOutLineProc( ScreenLine^, index, wid );
  103.     end;
  104.     DecodeBMP := true;
  105. end;
  106.  
  107. function LoadBMP( F : string ) : boolean;
  108. var
  109.     D: DirStr;
  110.     N: NameStr;
  111.     E: ExtStr;
  112.     FileHandle : File;
  113. begin
  114.     FSplit( F, D, N, E );
  115.     if E='' then E:='.BMP';
  116.     F := D+N+E;
  117.     {$I-}
  118.         assign( FileHandle, F );
  119.         reset( FileHandle, 1 );
  120.     {$I+}
  121.     if ioresult = 0 then
  122.         LoadBMP := DecodeBMP( FileHandle )
  123.     else
  124.         LoadBMP := false;
  125.     {$I-}
  126.         close( FileHandle );
  127.     {$I+}
  128. end; { LoadBMP }
  129.  
  130. function EncodeBMP( var f : file; width, depth : integer; var palette ) : boolean;
  131. var
  132.     BMPHead : BMPHeader;
  133.     hgt, wid, index, index2 : integer;
  134.     r, g, b : byte;
  135.     ScreenLine : pointer;
  136.     col : BMPRGB;
  137.     ThePalette : TByteArray absolute palette;
  138.  
  139. begin
  140.     fillchar( BMPHead, sizeof(BMPHeader),0 );
  141.     with BMPHead do
  142.     begin
  143.         id := 'BP';
  144.         headersize := 1078;
  145.         filesize := headersize + width*depth;
  146.         wid := width;
  147.         hgt := depth;
  148.         infosize := $28;
  149.         bits := 8;
  150.         biplanes := 1;
  151.         biCompression := 0;
  152.     end;
  153.  
  154.     blockwrite( f, BMPHead, SizeOf( BMPHead ) );
  155.     for index:=0 to 255 do
  156.     begin
  157.         col.r := ThePalette[index*3] shl 2;
  158.         col.g := ThePalette[index*3+1] shl 2;
  159.         col.b := ThePalette[index*3+2] shl 2;
  160.         blockwrite( f, col, SizeOf( BMPRGB ) );
  161.     end;
  162.     wid := width;
  163.     if wid mod 4<>0 then wid := wid + 4 - wid mod 4;
  164.     GetMem( ScreenLine, wid );
  165.     hgt := BMPHead.hgt-1;
  166.     for index:=hgt downto 0 do
  167.     begin
  168.         fillchar( ScreenLine^,wid,0);
  169.         for index2 := 0 to width-1 do
  170.             TByteArray(ScreenLine^)[index2] := BMPInPixelProc(index2,index);
  171.         blockwrite( f, ScreenLine^, wid );
  172.     end;
  173.     EncodeBMP := true;
  174. end;
  175.  
  176. function SaveBMP( f : string; width, depth : integer; var palette ) : boolean;
  177. var
  178.     D: DirStr;
  179.     N: NameStr;
  180.     E: ExtStr;
  181.     FileHandle : File;
  182. begin
  183.     FSplit( F, D, N, E );
  184.     if E='' then E:='.BMP';
  185.     F := D+N+E;
  186.     {$I-}
  187.         assign( FileHandle, F );
  188.         rewrite( FileHandle, 1 );
  189.     {$I+}
  190.     if ioresult = 0 then
  191.         SaveBMP := EncodeBMP( FileHandle, width, depth, palette )
  192.     else
  193.         SaveBMP := false;
  194.     {$I-}
  195.         close( FileHandle );
  196.     {$I+}
  197. end;
  198.  
  199. end.
  200.